home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / center2g / modperfo.bas < prev    next >
Encoding:
BASIC Source File  |  1999-09-01  |  12.7 KB  |  358 lines
  1. Attribute VB_Name = "modPerformanceAPI"
  2. Option Explicit
  3. Public StopSampling As Boolean
  4. Public hQuery As Long
  5. Public CounterIndex As Integer
  6. Public header(50) As String
  7.  
  8. Type CounterElement
  9.     hCounter As Long
  10.     dwType As Long
  11.     CVersion As Long
  12.     CStatus As Long
  13.     lScale As Long
  14.     lDefaultScale As Long
  15.     dwUserData As Long
  16.     dwQueryUserData As Long
  17.     szFullPath As String
  18.     szMachineName As String
  19.     szObjectName As String
  20.     szInstanceName As String
  21.     szParentInstance As String
  22.     dwInstanceIndex As Long
  23.     szCounterName As String
  24.     szExplainText As String
  25.     CounterValue As Double
  26. End Type
  27. Public CounterTable(255) As CounterElement
  28. Public PdhLastError As String
  29. Public PdhLastCounterPath As String
  30.  
  31. 'Multi Purpose Declares
  32. Private Declare Function PtrToStrA Lib "kernel32" Alias "lstrcpyA" (ByVal RetVal As String, ByVal Ptr As Long) As Long
  33. Private Declare Function StrLen Lib "kernel32" Alias "lstrlenW" (ByVal Ptr As Long) As Long
  34. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  35.  
  36. 'Performance Data Helper - Constants
  37. ' dwFormat flag values
  38. Public Const PDH_FMT_RAW = &H10
  39. Public Const PDH_FMT_ANSI = &H20
  40. Public Const PDH_FMT_UNICODE = &H40
  41. Public Const PDH_FMT_LONG = &H100
  42. Public Const PDH_FMT_DOUBLE = &H200
  43. Public Const PDH_FMT_LARGE = &H400
  44. Public Const PDH_FMT_NOSCALE = &H1000
  45. Public Const PDH_FMT_1000 = &H2000
  46. Public Const PDH_FMT_NODATA = &H4000
  47.  
  48. ' DetailLevel flag values
  49. Public Const PERF_DETAIL_NOVICE& = 100         ' The uninformed can understand it
  50. Public Const PERF_DETAIL_ADVANCED& = 200       ' For the advanced user
  51. Public Const PERF_DETAIL_EXPERT& = 300         ' For the expert user
  52. Public Const PERF_DETAIL_WIZARD& = 400         ' For the system designer
  53.  
  54. 'Performance Data Helper - Types
  55. Type PDH_COUNTER_INFO
  56.     dwLength As Long
  57.     dwType As Long
  58.     CVersion As Long
  59.     CStatus As Long
  60.     lScale As Long
  61.     lDefaultScale As Long
  62.     dwUserData As Long
  63.     dwQueryUserData As Long
  64.     szFullPath As Long
  65.     szMachineName As Long
  66.     szObjectName As Long
  67.     szInstanceName As Long
  68.     szParentInstance As Long
  69.     dwInstanceIndex As Long
  70.     szCounterName As Long
  71.     lpNull As Long
  72.     szExplainText As Long
  73.     DataBuffer(16) As Long
  74. End Type
  75.  
  76. 'Performance Data Helper - Functions
  77. Private Declare Function PdhOpenQuery Lib "pdh.dll" Alias "PdhVbOpenQuery" (hQuery As Long) As Long
  78. Private Declare Function PdhAddCounter Lib "pdh.dll" Alias "PdhVbAddCounter" (ByVal hQuery As Long, ByVal szFullCounterPath As String, hCounter As Long) As Long
  79. Private Declare Function PdhRemoveCounter Lib "pdh.dll" (ByVal hCounter As Long) As Long
  80. Private Declare Function PdhCollectQueryData Lib "pdh.dll" (ByVal hQuery As Long) As Long
  81. Private Declare Function PdhGetDoubleCounterValue Lib "pdh.dll" Alias "PdhVbGetDoubleCounterValue" (ByVal CounterHandle As Long, ByRef CounterStatus As Long) As Double
  82. Private Declare Function PdhCloseQuery Lib "pdh.dll" (ByVal hQuery As Long) As Long
  83. Private Declare Function PdhIsGoodStatus Lib "pdh.dll" Alias "PdhVbIsGoodStatus" (ByVal StatusValue As Long) As Long
  84. Private Declare Function PdhCreateCounterPathList Lib "pdh.dll" Alias "PdhVbCreateCounterPathList" (ByVal DetailLevel As Long, ByVal CaptionString As String) As Long
  85. Private Declare Function PdhGetOneCounterPath Lib "pdh.dll" Alias "PdhVbGetOneCounterPath" (ByVal PathString As String, ByVal PathLength As Long, ByVal DetailLevel As Long, ByVal CaptionString As String) As Long
  86. Private Declare Function PdhGetCounterPathFromList Lib "pdh.dll" Alias "PdhVbGetCounterPathFromList" (ByVal Index As Long, ByVal Buffer As String, ByVal BufferLength As Long) As Long
  87. Private Declare Function PdhGetCounterInfo Lib "pdh.dll" Alias "PdhGetCounterInfoA" (ByVal hCounter As Long, ByVal bRetrieveExplainText As Long, pdwBufferSize As Long, lpBuffer As Long) As Long
  88. Sub AddComputer(ByVal ComputerName As String)
  89.     Set ItmX = frmPerfExplorer.ListView.ListItems.Add(, "P" & CounterIndex - 1, ComputerName)
  90.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Errors During Script Runtime"
  91.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Errors From ASP Preprocessor"
  92.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Errors From Script Compilers"
  93.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Memory Allocated"
  94.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Request Bytes In Total"
  95.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Request Bytes Out Total"
  96.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Requests Failed Total"
  97.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Requests Succeeded"
  98.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Requests Timed Out"
  99.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Sessions Current"
  100.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Sessions Total"
  101.         'AddCounter "\\" & ComputerName & "\Active Server Pages\Template Cache Hit Rate"
  102.     '******************CPU
  103.      AddCounter "\\" & ComputerName & "\Processor(0)\% Processor Time"
  104.      AddCounter "\\" & ComputerName & "\Memory\% Committed Bytes In Use"
  105.      AddCounter "\\" & ComputerName & "\System\System Up Time"
  106.     '*******************************Web service
  107.      'AddCounter "\\" & ComputerName & "\Web Service\Bytes Sent/Sec"
  108.      'AddCounter "\\" & ComputerName & "\Web Service\Maximum Connections"
  109.     ' AddCounter "\\" & ComputerName & "\Web Service\Total Connections"
  110.      'AddCounter "\\" & ComputerName & "\Web Service\Total Files Recieved"
  111.      'AddCounter "\\" & ComputerName & "\Web Service\Total Files Sent"
  112.      'AddCounter "\\" & ComputerName & "\Web Service\Total Get Requests"
  113.      'AddCounter "\\" & ComputerName & "\Web Service\Total Post Requests"
  114.      'AddCounter "\\" & ComputerName & "\Web Service\Total ISAPI Extension Requests"
  115. End Sub
  116.  
  117.  
  118. Function PdhCounterInfo(ByVal Index As Integer) As Boolean
  119.     Dim X As Long
  120.     Dim lpBuffer() As Long
  121.     Dim pdwBufferSize As Long
  122.     
  123.     pdwBufferSize = 0
  124.     ReDim lpBuffer(0)
  125.     X = PdhGetCounterInfo(CounterTable(Index).hCounter, True, pdwBufferSize, lpBuffer(0))
  126.     ReDim lpBuffer((pdwBufferSize / 4) + 10)
  127.     X = PdhGetCounterInfo(CounterTable(Index).hCounter, True, pdwBufferSize, lpBuffer(0))
  128.     If PdhIsGoodStatus(X) = 0 Then
  129.         PdhLastError = GetPdhReturn(X)
  130.         PdhCounterInfo = False
  131.     Else
  132.         With CounterTable(Index)
  133.             .dwType = lpBuffer(1)
  134.             .CVersion = lpBuffer(2)
  135.             .CStatus = lpBuffer(3)
  136.             .lScale = lpBuffer(4)
  137.             .lDefaultScale = lpBuffer(5)
  138.             .dwUserData = lpBuffer(6)
  139.             .dwQueryUserData = lpBuffer(7)
  140.             .szFullPath = PointerToString(lpBuffer(8))
  141.             .szMachineName = PointerToString(lpBuffer(9))
  142.             .szObjectName = PointerToString(lpBuffer(10))
  143.             .szInstanceName = PointerToString(lpBuffer(11))
  144.             .szParentInstance = PointerToString(lpBuffer(12))
  145.             .dwInstanceIndex = lpBuffer(13)
  146.             .szCounterName = PointerToString(lpBuffer(14))
  147.             .szExplainText = PointerToString(lpBuffer(16))
  148.         End With
  149.         PdhCounterInfo = True
  150.     End If
  151.     
  152.     Erase lpBuffer
  153. End Function
  154.  
  155.  
  156.  
  157. Function PdhAdd(ByVal szFullCounterPath As String) As Boolean
  158.     Dim X As Long
  159.     
  160.     CounterTable(CounterIndex).hCounter = 0
  161.     X = PdhAddCounter(hQuery, szFullCounterPath, CounterTable(CounterIndex).hCounter)
  162.     If PdhIsGoodStatus(X) = 0 Then
  163.         PdhLastError = GetPdhReturn(X)
  164.         PdhAdd = False
  165.     Else
  166.         PdhAdd = True
  167.         CounterIndex = CounterIndex + 1
  168.     End If
  169. End Function
  170.  
  171. Function PdhCollect() As Boolean
  172.     Dim X As Long
  173.     
  174.     X = PdhCollectQueryData(hQuery)
  175.     If PdhIsGoodStatus(X) = 0 Then
  176.         PdhLastError = GetPdhReturn(X)
  177.         PdhCollect = False
  178.     Else
  179.         PdhCollect = True
  180.     End If
  181.  
  182. End Function
  183.  
  184. Function PdhCounterDialog1(ByVal CaptionString As String) As Boolean
  185.     Dim X As Long
  186.     Dim PathString As String
  187.     Dim PathLength As Long
  188.     
  189.     PathString = Space(255)
  190.     PathLength = 255
  191.     
  192.     X = PdhGetOneCounterPath(PathString, PathLength, PERF_DETAIL_WIZARD, CaptionString)
  193.     If X = 0 Then
  194.         PdhCounterDialog1 = False
  195.     Else
  196.         PdhLastCounterPath = Left$(PathString, X)
  197.         PdhCounterDialog1 = True
  198.     End If
  199.  
  200. End Function
  201.  
  202.  
  203. Function PdhCounterDialog2(ByVal CaptionString As String) As Boolean
  204.     Dim X As Long
  205.     
  206.     X = PdhCreateCounterPathList(PERF_DETAIL_ADVANCED&, CaptionString)
  207.     If PdhIsGoodStatus(X) = 0 Then
  208.         PdhLastError = GetPdhReturn(X)
  209.         PdhCounterDialog2 = False
  210.     Else
  211.         PdhCounterDialog2 = True
  212.     End If
  213.  
  214. End Function
  215.  
  216.  
  217.  
  218. Function PdhGetValue(ByVal Index As Integer, CounterValue As Double) As Boolean
  219.     Dim X As Long
  220.     Dim lpdwType As Long
  221.     Dim pValue As Double
  222.     
  223.     pValue = PdhGetDoubleCounterValue(CounterTable(Index).hCounter, X)
  224.     If PdhIsGoodStatus(X) = 0 Then
  225.         PdhLastError = GetPdhReturn(X)
  226.         PdhGetValue = False
  227.     Else
  228.         PdhGetValue = True
  229.         CounterValue = pValue
  230.     End If
  231.  
  232. End Function
  233.  
  234.  
  235. Function PdhOpen() As Boolean
  236.     Dim X As Long
  237.     
  238.     StopSampling = False
  239.     
  240.     hQuery = 0
  241.     X = PdhOpenQuery(hQuery)
  242.     If PdhIsGoodStatus(X) = 0 Then
  243.         PdhLastError = GetPdhReturn(X)
  244.         PdhOpen = False
  245.     Else
  246.         PdhOpen = True
  247.     End If
  248.  
  249. End Function
  250.  
  251.  
  252. Function PdhClose() As Boolean
  253.     Dim X As Long
  254.     
  255.     X = PdhCloseQuery(hQuery)
  256.     If PdhIsGoodStatus(X) = 0 Then
  257.         PdhLastError = GetPdhReturn(X)
  258.         PdhClose = False
  259.     Else
  260.         PdhClose = True
  261.     End If
  262. End Function
  263.  
  264. Function PointerToString(ByVal Pointer) As String
  265.     Dim StringValue As String
  266.     Dim NullPos As Long
  267.     Dim Temp As Long
  268.     
  269.     ' Copy string to array and convert to a string
  270.     If Pointer > 0 And StrLen(Pointer) > 0 Then
  271.         StringValue = Space$(StrLen(Pointer) * 2)
  272.         Temp = PtrToStrA(StringValue, Pointer)
  273.         NullPos = InStr(StringValue, Chr$(0))
  274.         If NullPos > 0 Then
  275.             PointerToString = Left$(StringValue, NullPos - 1) 'Lose the null terminator...
  276.         Else
  277.             PointerToString = StringValue 'Just pass the string...
  278.         End If
  279.     Else
  280.         PointerToString = ""
  281.     End If
  282. End Function
  283.  
  284.  
  285.  
  286. Sub AddCounter(ByVal CounterPath As String)
  287.  
  288.     If Not PdhAdd(CounterPath) Then
  289.         MsgBox "Error adding counter: " & PdhLastError
  290.     Else
  291.         Call PdhCounterInfo(CounterIndex - 1)
  292.         DoEvents
  293.     End If
  294.  
  295. End Sub
  296.  
  297. Sub SelectCounter()
  298.     Call PdhCounterDialog1("Select Performance Counter")
  299.     Debug.Print PdhLastCounterPath
  300.     Do While PdhCounterDialog1("Select Performance Counter") <> Empty
  301.         If Not PdhAdd(PdhLastCounterPath) Then
  302.             MsgBox "Error adding counter: " & PdhLastError
  303.         Else
  304.             Call PdhCounterInfo(CounterIndex - 1)
  305.         End If
  306.     Loop
  307.  
  308. End Sub
  309.  
  310.  
  311. Sub TakeSample()
  312.     Dim I As Integer
  313.     Dim lIndex As Integer
  314.     Dim strHtmPath As String
  315.     Dim intFile As Integer
  316.     header(0) = "Errors During Script Runtime"
  317.     header(1) = "Errors From ASP Preprocessor"
  318.     header(2) = "Errors From Script Compilers"
  319.     header(3) = "Memory Allocated"
  320.     header(4) = "Request Bytes In Total"
  321.     header(5) = "Request Bytes Out Total"
  322.     header(6) = "Requests Failed Total"
  323.     header(7) = "Requests Succeeded"
  324.     header(8) = "Requests Timed Out"
  325.     header(9) = "Sessions Current"
  326.     header(10) = "Sessions Total"
  327.     header(11) = "Template Cache Hit Rate"
  328.     header(12) = "Processor % In Use"
  329.     header(13) = "Memory % In Use"
  330.     header(14) = "System Up Time(Seconds)"
  331.     'header(15) = "Recieved"
  332.     'header(16) = "Gets"
  333.    ' header(17) = "Posts"
  334.     'header(18) = "ISAPI Requests"
  335.     intFile = FreeFile
  336.     strHtmPath = "c:\Stats.htm" '************HTM FILE
  337.     Open strHtmPath For Output As #intFile
  338.     Call PdhCollect
  339.         Print #intFile, "<HTML><TITLE>Server Stats</TITLE><BODY BGCOLOR=BLUE><FONT COLOR=WHITE><BR><B>Active Server Pages</B><br>"
  340.         For I = 0 To CounterIndex - 1
  341.         'lIndex = I Mod 2 + 1
  342.         If Not PdhGetValue(I, CounterTable(I).CounterValue) Then
  343.             Call WriteStatus(PdhLastError)
  344.         Else
  345.             Set ItmX = List.ListItems(1)
  346.             ItmX.SubItems(I + 1) = Format$(CounterTable(I).CounterValue, "0.00")
  347.             Print #intFile, header(I) & "   " & Format$(CounterTable(I).CounterValue, "0.00") & "<br>"
  348.         End If
  349.         If I = 11 Then Print #intFile, "<br> <b>General</b><br>"
  350.     Next I
  351.      Print #intFile, "</BODY></HTML>"
  352.     DoEvents
  353.     Close #intFile
  354.     
  355. End Sub
  356.  
  357.  
  358.